Visual Basic Graphics Programming (2nd Edition)/Visual Basic Graphics Programming 2nd Edition.iso/OldSrc/CH11/SRC/TRANS2.FRM

Text File | 1996-05-02 | 24KB | 839 lines

VERSION 4.00
Begin VB.Form RotatedForm
   Appearance      =   0  'Flat
   BackColor       =   &H00C0C0C0&
   Caption         =   "Surfaces of Rotation"
   ClientHeight    =   5700
   ClientLeft      =   630
   ClientTop       =   900
   ClientWidth     =   7830
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   1
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   Height          =   6390
   KeyPreview      =   -1  'True
   Left            =   570
   LinkTopic       =   "Form1"
   ScaleHeight     =   380
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   522
   Top             =   270
   Width           =   7950
   Begin VB.CheckBox HideCheck
      Caption         =   "Remove Hidden Surfaces"
      Height          =   255
      Left            =   0
      TabIndex        =   23
      Top             =   5400
      Width           =   2505
   End
   Begin VB.Frame Frame2
      Caption         =   "Curve"
      Height          =   5295
      Left            =   0
      TabIndex        =   8
      Top             =   0
      Width           =   2295
      Begin VB.OptionButton CurveChoice
         Caption         =   "Tornado"
         Height          =   255
         Index           =   13
         Left            =   120
         TabIndex        =   22
         Top             =   4920
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Helix"
         Height          =   255
         Index           =   12
         Left            =   120
         TabIndex        =   21
         Top             =   4560
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Tower"
         Height          =   255
         Index           =   11
         Left            =   120
         TabIndex        =   20
         Top             =   4200
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Football"
         Height          =   255
         Index           =   10
         Left            =   120
         TabIndex        =   19
         Top             =   3840
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Goblet"
         Height          =   255
         Index           =   9
         Left            =   120
         TabIndex        =   18
         Top             =   3480
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Urn"
         Height          =   255
         Index           =   8
         Left            =   120
         TabIndex        =   17
         Top             =   3120
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Sine Wave"
         Height          =   255
         Index           =   7
         Left            =   120
         TabIndex        =   16
         Top             =   2760
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Semicircle 2"
         Height          =   255
         Index           =   6
         Left            =   120
         TabIndex        =   15
         Top             =   2400
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Semicircle 1"
         Height          =   255
         Index           =   5
         Left            =   120
         TabIndex        =   14
         Top             =   2040
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Circle 2"
         Height          =   255
         Index           =   4
         Left            =   120
         TabIndex        =   13
         Top             =   1680
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Circle 1"
         Height          =   255
         Index           =   3
         Left            =   120
         TabIndex        =   12
         Top             =   1320
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "3/4 Rectangle"
         Height          =   255
         Index           =   2
         Left            =   120
         TabIndex        =   11
         Top             =   960
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Diamond"
         Height          =   255
         Index           =   1
         Left            =   120
         TabIndex        =   10
         Top             =   600
         Width           =   2055
      End
      Begin VB.OptionButton CurveChoice
         Caption         =   "Rectangle"
         Height          =   255
         Index           =   0
         Left            =   120
         TabIndex        =   9
         Top             =   240
         Value           =   -1  'True
         Width           =   2055
      End
   End
   Begin VB.CheckBox ShowAxesCheck
      Caption         =   "Show Axes"
      Height          =   255
      Left            =   2520
      TabIndex        =   7
      Top             =   5400
      Width           =   1335
   End
   Begin VB.TextBox PhiText
      Height          =   285
      Left            =   6960
      TabIndex        =   6
      Text            =   "0.1570"
      Top             =   5400
      Width           =   855
   End
   Begin VB.TextBox ThetaText
      Height          =   285
      Left            =   5640
      TabIndex        =   4
      Text            =   "0.6283"
      Top             =   5400
      Width           =   855
   End
   Begin VB.TextBox RText
      Height          =   285
      Left            =   4080
      TabIndex        =   2
      Text            =   "10"
      Top             =   5400
      Width           =   855
   End
   Begin VB.PictureBox Pict
      AutoRedraw      =   -1  'True
      BackColor       =   &H00C0C0C0&
      ForeColor       =   &H00000000&
      Height          =   5295
      Left            =   2400
      ScaleHeight     =   349
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   357
      TabIndex        =   0
      Top             =   0
      Width           =   5415
   End
   Begin MSComDlg.CommonDialog LoadDialog
      Left            =   1800
      Top             =   5280
      _version        =   65536
      _extentx        =   847
      _extenty        =   847
      _stockprops     =   0
      cancelerror     =   -1  'True
   End
   Begin VB.Label Label1
      Caption         =   "Phi"
      Height          =   255
      Index           =   2
      Left            =   6600
      TabIndex        =   5
      Top             =   5415
      Width           =   375
   End
   Begin VB.Label Label1
      Caption         =   "Theta"
      Height          =   255
      Index           =   1
      Left            =   5040
      TabIndex        =   3
      Top             =   5415
      Width           =   495
   End
   Begin VB.Label Label1
      Caption         =   "R"
      Height          =   255
      Index           =   0
      Left            =   3840
      TabIndex        =   1
      Top             =   5415
      Width           =   255
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuFileLoad
         Caption         =   "&Load..."
         Shortcut        =   ^L
      End
      Begin VB.Menu mnuFileSaveAs
         Caption         =   "Save &As..."
         Shortcut        =   ^A
      End
      Begin VB.Menu mnuFileSaveAsSolid
         Caption         =   "Save As &Solid..."
      End
      Begin VB.Menu mnuFileSep
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit
         Caption         =   "E&xit"
      End
   End
End
Attribute VB_Name = "RotatedForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit

' Location of viewing eye.
Dim EyeR As Single
Dim EyeTheta As Single
Dim EyePhi As Single

Const dtheta = PI / 20
Const Dphi = PI / 20
Const Dr = 1

' Location of focus point.
Const FocusX = 0#
Const FocusY = 0#
Const FocusZ = 0#

Dim Projector(1 To 4, 1 To 4) As Single

Dim CurveNum As Integer

Dim ThePicture As ObjPicture
Dim TheSurface As ObjTransformed

Dim ShowingParameters As Boolean

' ************************************************
' Create the selected curve.
' ************************************************
Sub CreateCurve()
Dim r As Single
Dim offset As Single
Dim dtheta As Single
Dim theta As Single
Dim Y As Single

    Select Case CurveNum
        Case 0  ' Rectangle.
            TheSurface.AddCurvePoint -3, -1.5, 0
            TheSurface.AddCurvePoint -1, -1.5, 0
            TheSurface.AddCurvePoint -1, 1.5, 0
            TheSurface.AddCurvePoint -3, 1.5, 0
            TheSurface.AddCurvePoint -3, -1.5, 0

        Case 1  ' Diamond.
            TheSurface.AddCurvePoint -3, 0, 0
            TheSurface.AddCurvePoint -2, -1, 0
            TheSurface.AddCurvePoint -1, 0, 0
            TheSurface.AddCurvePoint -2, 1, 0
            TheSurface.AddCurvePoint -3, 0, 0

        Case 2  ' 3/4 Rectangle.
            TheSurface.AddCurvePoint 0, 1.5, 0
            TheSurface.AddCurvePoint -3, 1.5, 0
            TheSurface.AddCurvePoint -3, -1.5, 0
            TheSurface.AddCurvePoint 0, -1.5, 0

        Case 3, 4   ' Circle 1, circle 2.
            If CurveNum = 3 Then
                r = 2
                offset = 2
            Else
                r = 1.5
                offset = 2.5
            End If
            dtheta = PI / 8
            TheSurface.AddCurvePoint offset + r, 0, 0
            For theta = -dtheta To -2 * PI + dtheta - 0.1 Step -dtheta
                TheSurface.AddCurvePoint _
                    offset + r * Cos(theta), r * Sin(theta), 0
            Next theta
            TheSurface.AddCurvePoint offset + r, 0, 0

        Case 5, 6   ' Semicircle 1, semicircle 2.
            If CurveNum = 5 Then
                r = 4
                offset = 0
            Else
                r = 2
                offset = 2
            End If
            dtheta = PI / 8
            If CurveNum = 6 Then _
                TheSurface.AddCurvePoint 0, r, 0
            For theta = PI / 2 To -PI / 2 + dtheta - 0.1 Step -dtheta
                TheSurface.AddCurvePoint _
                    offset + r * Cos(theta), _
                    r * Sin(theta), _
                    0
            Next theta
            TheSurface.AddCurvePoint offset, -r, 0
            If CurveNum = 6 Then _
                TheSurface.AddCurvePoint 0, -r, 0

        Case 7  ' Sine wave.
            r = 0.7
            dtheta = PI / 10
            TheSurface.AddCurvePoint 0, PI, 0
            For theta = PI To -PI Step -dtheta
                TheSurface.AddCurvePoint _
                    1 + r + r * Sin(2 * theta), _
                    theta, _
                    0
            Next theta
            TheSurface.AddCurvePoint 0, theta + dtheta, 0

        Case 8  ' Urn.
            dtheta = PI / 10
            TheSurface.AddCurvePoint 0, PI, 0
            For theta = PI To -PI Step -dtheta
                TheSurface.AddCurvePoint _
                    PI / 2 + (-PI + theta) / 4 * Sin(2 * theta), _
                    theta, _
                    0
            Next theta
            TheSurface.AddCurvePoint 0, theta + dtheta, 0

        Case 9  ' Goblet.
            TheSurface.AddCurvePoint 0, 3.5, 0
            TheSurface.AddCurvePoint 3, 3.5, 0
            TheSurface.AddCurvePoint 2.5, 3, 0
            TheSurface.AddCurvePoint 3, 1.5, 0
            TheSurface.AddCurvePoint 2.5, 1, 0
            TheSurface.AddCurvePoint 1, 1, 0
            TheSurface.AddCurvePoint 0.5, 0.5, 0
            TheSurface.AddCurvePoint 0.5, -1, 0
            TheSurface.AddCurvePoint 1, -1.5, 0
            TheSurface.AddCurvePoint 2, -1.5, 0
            TheSurface.AddCurvePoint 2.5, -2, 0
            TheSurface.AddCurvePoint 0, -2, 0

        Case 10 ' Football.
            For Y = 4 To -4 Step -0.5
                TheSurface.AddCurvePoint 16 / 5 - Y * Y / 5, Y, 0
            Next Y

        Case 11 ' Tower.
            r = 1
            dtheta = PI / 8
            For theta = -PI To -PI / 2 Step dtheta
                TheSurface.AddCurvePoint _
                    r + r * Cos(theta), _
                    4 * r + r * Sin(theta), _
                    0
            Next theta
            For theta = PI / 2 To -PI / 2 Step -dtheta
                TheSurface.AddCurvePoint _
                    r + r * Cos(theta), _
                    2 * r + r * Sin(theta), _
                    0
            Next theta
            TheSurface.AddCurvePoint r, -3, 0
            TheSurface.AddCurvePoint 0, -3, 0

        Case 12 ' Helix.
            r = 2
            dtheta = PI / 4
            TheSurface.AddCurvePoint 0, PI, 0
            For theta = PI To -PI Step -dtheta
                TheSurface.AddCurvePoint _
                    r * Cos(theta / 2), _
                    theta, _
                    r * Sin(theta / 2)
            Next theta
            TheSurface.AddCurvePoint 0, theta + dtheta, 0

        Case 13 ' Tornado.
            r = 2
            dtheta = PI / 4
            TheSurface.AddCurvePoint 0, PI, 0
            For theta = PI To -PI Step -dtheta
                r = 2 + theta / 2
                TheSurface.AddCurvePoint _
                    r * Cos(theta / 2), _
                    theta, _
                    r * Sin(theta / 2)
            Next theta
            TheSurface.AddCurvePoint 0, theta + dtheta, 0

    End Select
End Sub

' ************************************************
' Create the transformation.
' ************************************************
Sub CreateTransformation()
Dim t(1 To 4, 1 To 4) As Single
Dim theta As Single
Dim dtheta As Single
Dim i As Integer

    dtheta = 2 * PI / 12
    For i = 1 To 12
        theta = i * dtheta
        m3YRotate t, theta      ' Rotate.
        TheSurface.SetTrans t
    Next i
End Sub


Sub WaitEnd()
    MousePointer = vbDefault
End Sub

Sub WaitStart()
    MousePointer = vbHourglass
    DoEvents
End Sub

' ************************************************
' Create a new curve and rotate it.
' ************************************************
Private Sub CurveChoice_Click(Index As Integer)
Dim pline As ObjPolyline

    WaitStart
    Set ThePicture = New ObjPicture
    Set TheSurface = New ObjTransformed
    ThePicture.Objects.Add TheSurface

    CurveNum = Index
    CreateCurve
    CreateTransformation

    TheSurface.Transform False

    If ShowAxesCheck.value = vbChecked Then
        Set pline = New ObjPolyline
        ThePicture.Objects.Add pline
        pline.AddSegment 0, 0, 0, 5, 0, 0
        pline.AddSegment 0, 0, 0, 0, 5, 0
        pline.AddSegment 0, 0, 0, 0, 0, 5
    End If

    DrawData Pict
    Pict.SetFocus
End Sub

' ************************************************
' Display the data.
' ************************************************
Private Sub DrawData(pic As Object)
Dim x As Single
Dim Y As Single
Dim z As Single
Dim S(1 To 4, 1 To 4) As Single
Dim t(1 To 4, 1 To 4) As Single
Dim ST(1 To 4, 1 To 4) As Single
Dim PST(1 To 4, 1 To 4) As Single
Dim edge_pen As Long
Dim old_pen As Long
Dim fill_brush As Long
Dim old_brush As Long
Dim status As Long

    MousePointer = vbHourglass
    Refresh

    ' Prevent overflow errors when drawing lines
    ' too far out of bounds.
    On Error Resume Next

    ' Scale and translate so it looks OK in pixels.
    m3Scale S, 35, -35, 1
    m3Translate t, 180, 200, 0
    m3MatMultiplyFull ST, S, t
    m3MatMultiplyFull PST, Projector, ST

    ' If we are removing hidden surfaces, cull now.
    If HideCheck.value = vbChecked Then
        m3SphericalToCartesian EyeR, EyeTheta, EyePhi, x, Y, z
        ThePicture.Cull x, Y, z
    Else
        ThePicture.Culled = False
    End If

    ' Transform the points.
    ThePicture.ApplyFull PST

    ' Display the data.
    pic.Cls
    If HideCheck.value = vbChecked Then
        m3SphericalToCartesian EyeR, EyeTheta, EyePhi, x, Y, z
        ThePicture.Cull x, Y, z

        ' Get a pen and brush.
        edge_pen = CreatePen(PS_SOLID, pic.DrawWidth, pic.ForeColor)
        old_pen = SelectObject(pic.hdc, edge_pen)
        fill_brush = CreateSolidBrush(pic.BackColor)
        old_brush = SelectObject(pic.hdc, fill_brush)

        ThePicture.DrawOrdered pic, EyeR

        ' Restore the old pen and brush.
        edge_pen = SelectObject(pic.hdc, old_pen)
        fill_brush = SelectObject(pic.hdc, old_brush)
        status = DeleteObject(edge_pen)
        status = DeleteObject(fill_brush)
    Else
        ThePicture.Draw pic, EyeR
    End If
    pic.Refresh

    ' Display the viewnig parameters.
    ShowViewingParameters

    MousePointer = vbDefault
End Sub

Sub ShowViewingParameters()
    ShowingParameters = True

    RText.Text = Format$(EyeR, "0.0000")
    ThetaText.Text = Format$(EyeTheta, "0.0000")
    PhiText.Text = Format$(EyePhi, "0.0000")

    RText.Refresh
    ThetaText.Refresh
    PhiText.Refresh

    ShowingParameters = False
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
        Case vbKeyLeft
            EyeTheta = EyeTheta - dtheta

        Case vbKeyRight
            EyeTheta = EyeTheta + dtheta

        Case vbKeyUp
            EyePhi = EyePhi - Dphi

        Case vbKeyDown
            EyePhi = EyePhi + Dphi

        Case Else
            Exit Sub
    End Select

    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub


Private Sub Form_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
        Case Asc("+")
            EyeR = EyeR + Dr

        Case Asc("-")
            EyeR = EyeR - Dr

        Case Else
            Exit Sub
    End Select

    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub

Private Sub Form_Load()
    ' Initialize the eye position.
    EyeR = 10
    EyeTheta = PI * 0.2
    EyePhi = PI * 0.1

    ' Initialize the projection transformation.
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0

    Me.Show
    CurveChoice_Click 0
End Sub


Private Sub mnuFileExit_Click()
    Unload Me
End Sub


Private Sub mnuFileLoad_Click()
Dim fname As String
Dim filenum As Integer
Dim txt As String
Dim Xmin As Single
Dim ymin As Single
Dim xmax As Single
Dim ymax As Single
Dim i As Integer

    ' Allow the user to pick a file.
    On Error Resume Next
    LoadDialog.filename = "*.APF"
    LoadDialog.ShowOpen
    If Err.Number = cdlCancel Then
        Unload LoadDialog
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Unload LoadDialog
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    fname = LoadDialog.filename
    LoadDialog.InitDir = Left$(fname, Len(fname) _
        - Len(LoadDialog.FileTitle) - 1)

    ' Clear the picture.
    Set ThePicture = Nothing

    ' Open the file.
    filenum = FreeFile
    Open fname For Input As #filenum

    ' Make sure it's an Object Picture File.
    Input #filenum, txt
    If txt <> "3D APF PICTURE" Then
        Close filenum
        Beep
        MsgBox "Error reading file """ & fname & """.", , vbExclamation
        Exit Sub
    End If

    ' Read the picture.
    MousePointer = vbHourglass
    DoEvents
    Set ThePicture = New ObjPicture
    ThePicture.FileInput filenum

    ' Close the file.
    Close filenum

    ' Refresh the display.
    DrawData Pict

    ' Deselect all the option buttons.
    For i = 0 To 13
        If CurveChoice(i).value Then _
            CurveChoice(i).value = False
    Next i

    MousePointer = vbDefault
End Sub

' ************************************************
' Allow the user to save the ObjTransformed
' object's display solid.
' ************************************************
Private Sub mnuFileSaveAsSolid_Click()
Dim fname As String
Dim filenum As Integer

    ' Allow the user to pick a file.
    On Error Resume Next
    LoadDialog.filename = "*.APF"
    LoadDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
    LoadDialog.ShowSave
    If Err.Number = cdlCancel Then
        Unload LoadDialog
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Unload LoadDialog
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    fname = LoadDialog.filename
    LoadDialog.InitDir = Left$(fname, Len(fname) _
        - Len(LoadDialog.FileTitle) - 1)

    ' Open the file.
    filenum = FreeFile
    Open fname For Output As #filenum

    ' Write the picture.
    Write #filenum, "3D APF PICTURE"
    Write #filenum, 1
    TheSurface.FileWriteSolid filenum

    ' Close the file.
    Close filenum
End Sub

' ************************************************
' Allow the user to save the ObjTransformed object.
' ************************************************
Private Sub mnuFileSaveAs_Click()
Dim fname As String
Dim filenum As Integer

    ' Allow the user to pick a file.
    On Error Resume Next
    LoadDialog.filename = "*.APF"
    LoadDialog.Flags = cdlOFNOverwritePrompt + cdlOFNHideReadOnly
    LoadDialog.ShowSave
    If Err.Number = cdlCancel Then
        Unload LoadDialog
        Exit Sub
    ElseIf Err.Number <> 0 Then
        Unload LoadDialog
        Beep
        MsgBox "Error selecting file.", , vbExclamation
        Exit Sub
    End If
    On Error GoTo 0

    fname = LoadDialog.filename
    LoadDialog.InitDir = Left$(fname, Len(fname) _
        - Len(LoadDialog.FileTitle) - 1)

    ' Open the file.
    filenum = FreeFile
    Open fname For Output As #filenum

    ' Write the picture.
    ThePicture.FileWrite filenum

    ' Close the file.
    Close filenum
End Sub

Private Sub PhiText_Change()
    If ShowingParameters Then Exit Sub
    EyePhi = CSng(PhiText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub


Private Sub RText_Change()
    If ShowingParameters Then Exit Sub
    EyeR = CSng(RText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub


' ************************************************
' Redraw with the hidden surfaces on or off.
' ************************************************
Private Sub HideCheck_Click()
    DrawData Pict
End Sub
' ************************************************
' Redraw with the axes on or off as appropriate.
' ************************************************
Private Sub ShowAxesCheck_Click()
    CurveChoice_Click CurveNum
End Sub


Private Sub ThetaText_Change()
    If ShowingParameters Then Exit Sub
    EyeTheta = CSng(ThetaText.Text)
    m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
    DrawData Pict
End Sub